home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
ghostbbs.zip
/
COMPMESS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-12-17
|
5KB
|
226 lines
const
maxlength = 50;
maxmess = 400;
numsects = 20;
type
str2 = string[2];
name = string[14];
longname = string[25];
filbuffer = array[0..127] of byte;
rate = (slow,fast);
line = string[80];
person = string[27];
str10 = string[10];
long = string[150];
messages = record
sender :person;
recver :longname;
subject :longname;
date :name;
messno :integer;
pointer :integer;
end;
messrec = record
mtext : string[80];
pmess : integer;
end;
sectrec = record
sectname : string[25];
sectaccess : byte;
specaccess : byte;
end;
sectnames = array[1..numsects] of sectrec;
messtext = array[1..maxlength] of line;
var
sections : sectnames;
tempmess : messages;
messagefile, outmess : file of messages;
textfile, outtext : file of messrec;
count: integer;
messtable: array[0..maxmess] of messages;
subdir : longname;
block : messtext;
tempsub : integer;
subboard : byte;
nextmess : byte;
lastline : byte;
jj : byte;
errcode : integer;
parm : string[10];
loop : integer;
function namemess(number: integer):line;
{ constructs file name for messages data files}
var temp:name;
begin
str(number,temp);
namemess := 'MESS' + temp + '.BBS';
end;
function outnamemess(number: integer):line;
{ constructs file name for messages data files}
var temp:name;
begin
str(number,temp);
outnamemess := 'XMESS' + temp + '.BBS';
end;
function nametitle(number: integer):line;
{ constructs file name for messages title files}
var temp:name;
begin
str(number,temp);
nametitle := 'TITLE' + temp + '.BBS';
end;
function outnametitle(number: integer):line;
{ constructs file name for messages title files}
var temp:name;
begin
str(number,temp);
outnametitle := 'XTITL' + temp + '.BBS';
end;
procedure initmess;
begin
writeln('Getting Messages ...');
count := 0;
assign(messagefile, nametitle(subboard));
{$I-} reset(messagefile) {$I+};
if IOresult = 0
then begin
while not eof(messagefile) do
begin
count := count + 1;
read(messagefile, messtable[count]);
end
end else rewrite(messagefile);
close(messagefile);
nextmess := count + 1;
assign (textfile,namemess(subboard));
{$I-}
reset(textfile);
{$I+}
if IoResult <> 0 then rewrite(textfile);
writeln('There are ', count , ' Messages.');
end;
procedure closemess;
var
loop: byte;
begin
assign(messagefile,nametitle(subboard));
rewrite(messagefile);
for loop := 1 to count do
write(messagefile, messtable[loop]);
close(messagefile);
close(textfile);
end;
function transmess(tabloc:byte):boolean;
var
rtext : messrec;
begin
lastline := 1;
reset(textfile);
seek(textfile,messtable[tabloc].pointer);
{$I-}
read(textfile,rtext);
{$I+}
if ioresult <> 0
then begin
transmess := false;
exit;
end;
block[lastline] := rtext.mtext;
while (rtext.pmess > 0) do
begin
seek(textfile,rtext.pmess);
{$I-}
read(textfile,rtext);
{$I+}
if ioresult <> 0
then begin
transmess := false;
exit;
end;
lastline := lastline + 1;
block[lastline] := rtext.mtext;
end;
transmess := true;
end;
var
tabloc: byte;
linenum: byte;
procedure storemess(tabloc: byte);
var
linenum: byte;
freearray : array[1..maxlength] of integer;
i : integer;
temp : messrec;
procedure get_next;
var i , j ,errcode : integer;
begin
errcode := 0;
i := 0;
j := 0;
reset(outtext);
if filesize(outtext) = 0 then j := 0
else j := filesize(outtext);
while (i < lastline) do
begin
i := i + 1;
freearray[i] := j;
j := j + 1;
end;
end;
begin {storemess}
reset(outtext);
get_next;
linenum := 1;
messtable[tabloc].pointer := freearray[1];
while linenum <= lastline do begin
if linenum = lastline then temp.pmess := 0
else temp.pmess := freearray[linenum+1];
temp.mtext := block[linenum];
seek(outtext,freearray[linenum]);
write(outtext,temp);
linenum := linenum + 1;
end;
end;
begin
parm := paramstr(1);
val(parm,tempsub,errcode);
if (errcode <> 0) then exit;
subboard := tempsub;
assign(outtext,outnamemess(subboard));
rewrite(outtext);
writeln('Compressing message base # ',subboard);
initmess;
for jj := 1 to count do
begin
writeln('Compressing Message #',jj);
if transmess(jj)
then storemess(jj)
else begin
for loop := jj + 1 to count do
messtable[loop-1] := messtable[loop];
count := count - 1;
end;
end;
close(outtext);
closemess;
end.